VERSION 1.0 CLASS BEGIN MultiUse = -1 'True Persistable = 0 'NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone MTSTransactionMode = 0 'NotAnMTSObject END Attribute VB_Name = "CSocket" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False '******************************************************************************** 'CSocket class 'Copyright © 2002 by Oleg Gdalevich 'Visual Basic Internet Programming website (http://www.vbip.com) '******************************************************************************** 'To use this class module you need: ' MSocketSupport code module '******************************************************************************** 'Version: 1.0.12 Modified: 17-OCT-2002 '******************************************************************************** 'To get latest version of this code please visit the following web page: 'http://www.vbip.com/winsock-api/csocket-class/csocket-class-01.asp '******************************************************************************** Option Explicit ' 'Added: 23-AUG-2002 Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lparam As Long) As Long ' 'The CSocket protocol's constants as for 'the MS Winsock Control interface Public Enum ProtocolConstants sckTCPProtocol = 0 sckUDPProtocol = 1 End Enum ' 'The CSocket error's constants as for 'the MS Winsock Control interface Public Enum ErrorConstants sckAddressInUse = 10048 sckAddressNotAvailable = 10049 sckAlreadyComplete = 10037 sckAlreadyConnected = 10056 sckBadState = 40006 sckConnectAborted = 10053 sckConnectionRefused = 10061 sckConnectionReset = 10054 sckGetNotSupported = 394 sckHostNotFound = 11001 sckHostNotFoundTryAgain = 11002 sckInProgress = 10036 sckInvalidArg = 40014 sckInvalidArgument = 10014 sckInvalidOp = 40020 sckInvalidPropertyValue = 380 sckMsgTooBig = 10040 sckNetReset = 10052 sckNetworkSubsystemFailed = 10050 sckNetworkUnreachable = 10051 sckNoBufferSpace = 10055 sckNoData = 11004 sckNonRecoverableError = 11003 sckNotConnected = 10057 sckNotInitialized = 10093 sckNotSocket = 10038 sckOpCanceled = 10004 sckOutOfMemory = 7 sckOutOfRange = 40021 sckPortNotSupported = 10043 sckSetNotSupported = 383 sckSocketShutdown = 10058 sckSuccess = 40017 sckTimedout = 10060 sckUnsupported = 40018 sckWouldBlock = 10035 sckWrongProtocol = 40026 End Enum ' 'The CSocket state's constants as for 'the MS Winsock Control interface Public Enum StateConstants sckClosed = 0 sckOpen sckListening sckConnectionPending sckResolvingHost sckHostResolved sckConnecting sckConnected sckClosing sckError End Enum ' 'In order to resolve a host name the MSocketSupport.ResolveHost 'function can be called from the Connect and SendData methods 'of this class. The callback acceptor for that routine is the 'PostGetHostEvent procedure. This procedure determines what to 'do next with the received host's address checking a value of 'the m_varInternalState variable. Private Enum InternalStateConstants istConnecting istSendingDatagram End Enum ' Private m_varInternalState As InternalStateConstants ' 'Local (module level) variables to hold values of the 'properties of this (CSocket) class. Private mvarProtocol As ProtocolConstants Private mvarState As StateConstants Private m_lngBytesReceived As Long Private m_strLocalHostName As String Private m_strLocalIP As String Private m_lngLocalPort As Long Private m_strRemoteHost As String Private m_strRemoteHostIP As String Private m_lngRemotePort As Long Private m_lngSocketHandle As Long ' 'Resolving host names is performed in an asynchronous mode, 'the m_lngRequestID variable just holds the value returned 'by the ResolveHost function from the MSocketSupport module. Private m_lngRequestID As Long ' 'Internal (for this class) buffers. They are the VB Strings. 'Don't trust that guy who told that the VB String data type 'cannot properly deal with binary data. Actually, it can, and 'moreover you have a lot of means to deal with that data - 'the VB string functions (such as Left, Mid, InStr and so on). 'If you need to get a byte array from a string, just call the 'StrConv function: ' 'byteArray() = StrConv(strBuffer, vbFromUnicode) ' Private m_strSendBuffer As String 'The internal buffer for outgoing data Private m_strRecvBuffer As String 'The internal buffer for incoming data ' 'Lenght of the Winsock buffers. By default = 8192 bytes for TCP sockets. 'These values are initialized in the SocketExists function. 'Now, I really don't know why I was in need to get these values. Private m_lngSendBufferLen As Long Private m_lngRecvBufferLen As Long ' 'Maximum size of a datagram that can be sent through 'a message-oriented (UDP) socket. This value is returned 'by the InitWinsock function from the MSocketSupport module. Private m_lngMaxMsgSize As Long ' 'This flag variable indicates that the socket is bound to 'some local socket address Private m_blnSocketIsBound As Boolean 'Added: 10-MAR-2002 ' Private m_blnSendFlag As Boolean 'Added: 12-SEP-2002 ' 'This flag variable indicates that the SO_BROADCAST option 'is set on the socket Private m_blnBroadcast As Boolean 'Added: 09-JULY-2002 ' 'These are those MS Winsock's events. 'Pay attention that the "On" prefix is added. Public Event OnClose() Attribute OnClose.VB_Description = "Occurs when the connection has been closed" Public Event OnConnect() Attribute OnConnect.VB_Description = "Occurs connect operation is completed" Public Event OnConnectionRequest(ByVal requestID As Long) Public Event OnDataArrival(ByVal bytesTotal As Long) Public Event OnError(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean) Public Event OnSendComplete() Public Event OnSendProgress(ByVal bytesSent As Long, ByVal bytesRemaining As Long) Public Sub SendData(varData As Variant) Attribute SendData.VB_Description = "Send data to remote computer" ' 'data to send - will be built from the varData argument Dim arrData() As Byte 'value returned by the send(sendto) Winsock API function Dim lngRetValue As Long 'length of the data to send - needed to call the send(sendto) Winsock API function Dim lngBufferLength As Long 'this strucure just contains address of the remote socket to send data to; 'only for UDP sockets when the sendto Winsock API function is used Dim udtSockAddr As sockaddr_in ' On Error Resume Next ' 'If a connection-oriented (TCP) socket was not created or connected to the 'remote host before calling the SendData method, the MS Winsock Control 'raises the sckBadState error. If mvarProtocol = sckTCPProtocol Then ' If m_lngSocketHandle = INVALID_SOCKET Then Exit Sub ' Else ' 'If the socket is a message-oriented one (UDP), this is OK to create 'it with the call of the SendData method. The SocketExists function 'creates a new socket. If Not SocketExists Then Exit Sub ' End If ' Select Case varType(varData) Case vbArray + vbByte 'Modified 28-MAY-2002. Thanks to Michael Freidgeim '-------------------------------- 'Dim strArray As String 'strArray = CStr(varData) arrData() = varData '-------------------------------- Case vbBoolean Dim blnData As Boolean blnData = CBool(varData) ReDim arrData(LenB(blnData) - 1) CopyMemory arrData(0), blnData, LenB(blnData) Case vbByte Dim bytData As Byte bytData = CByte(varData) ReDim arrData(LenB(bytData) - 1) CopyMemory arrData(0), bytData, LenB(bytData) Case vbCurrency Dim curData As Currency curData = CCur(varData) ReDim arrData(LenB(curData) - 1) CopyMemory arrData(0), curData, LenB(curData) Case vbDate Dim datData As Date datData = CDate(varData) ReDim arrData(LenB(datData) - 1) CopyMemory arrData(0), datData, LenB(datData) Case vbDouble Dim dblData As Double dblData = CDbl(varData) ReDim arrData(LenB(dblData) - 1) CopyMemory arrData(0), dblData, LenB(dblData) Case vbInteger Dim intData As Integer intData = CInt(varData) ReDim arrData(LenB(intData) - 1) CopyMemory arrData(0), intData, LenB(intData) Case vbLong Dim lngData As Long lngData = CLng(varData) ReDim arrData(LenB(lngData) - 1) CopyMemory arrData(0), lngData, LenB(lngData) Case vbSingle Dim sngData As Single sngData = CSng(varData) ReDim arrData(LenB(sngData) - 1) CopyMemory arrData(0), sngData, LenB(sngData) Case vbString Dim strData As String strData = CStr(varData) ReDim arrData(Len(strData) - 1) arrData() = StrConv(strData, vbFromUnicode) Case Else ' 'Unknown data type ' End Select ' 'Store all the data to send in the module level 'variable m_strSendBuffer. m_strSendBuffer = StrConv(arrData(), vbUnicode) ' 'Call the SendBufferedData subroutine in order to send the data. 'The SendBufferedData sub is just a common procedure that is 'called from different places in this class. 'Nothing special - just the code reuse. m_blnSendFlag = True Call SendBufferedData ' End Sub Public Sub PeekData(varData As Variant, Optional varType As Variant, Optional maxLen As Variant) Attribute PeekData.VB_Description = "Look at incoming data without removing it from the buffer" ' Dim lngBytesReceived As Long 'value returned by the RecvData function ' On Error Resume Next ' 'The RecvData is a universal subroutine that can either to retrieve or peek 'data from the Winsock buffer. If a value of the second argument (blnPeek As Boolean) 'of the RecvData subroutine is True, it will be just peeking. lngBytesReceived = RecvData(varData, True, IIf(IsMissing(varType), Empty, varType), _ IIf(IsMissing(maxLen), Empty, maxLen)) ' End Sub Public Sub Listen() Attribute Listen.VB_Description = "Listen for incoming connection requests" ' Dim lngRetValue As Long 'value returned by the listen Winsock API function ' On Error Resume Next ' 'SocketExists is not a variable. It is a function that can 'create a socket, if the class has no one. If Not SocketExists Then Exit Sub ' 'The listen Winsock API function cannot be called 'without the call of the bind one. If Not m_blnSocketIsBound Then 'Added: 10-MAR-2002 Call Bind End If 'Added: 10-MAR-2002 ' 'Turn the socket into a listening state lngRetValue = api_listen(m_lngSocketHandle, 5&) ' If lngRetValue = SOCKET_ERROR Then mvarState = sckError Else mvarState = sckListening End If End Sub Public Sub GetData(varData As Variant, Optional varType As Variant, Optional maxLen As Variant) Attribute GetData.VB_Description = "Retrieve data sent by the remote computer" ' Dim lngBytesReceived As Long 'value returned by the RecvData function ' On Error Resume Next ' 'A value of the second argument of the RecvData subroutine is False, so in this way 'this procedure will retrieve incoming data from the buffer. lngBytesReceived = RecvData(varData, False, IIf(IsMissing(varType), Empty, varType), _ IIf(IsMissing(maxLen), Empty, maxLen)) ' End Sub Public Sub Connect(Optional strRemoteHost As Variant, Optional lngRemotePort As Variant) Attribute Connect.VB_Description = "Connect to the remote computer" ' Dim lngHostAddress As Long '32 bit host address Dim udtAddress As sockaddr_in 'socket address - used by the connect Winsock API function Dim lngRetValue As Long 'value returned by the connect Winsock API function ' On Error Resume Next ' 'If no socket has been created before, try to create a new one If Not SocketExists Then Exit Sub ' 'If the arguments of this function are not missing, they 'overwrite values of the RemoteHost and RemotePort properties. ' If Not IsMissing(strRemoteHost) Then 'Added: 04-MAR-2002 If Len(strRemoteHost) > 0 Then m_strRemoteHost = CStr(strRemoteHost) End If End If 'Added: 04-MAR-2002 ' If Not IsMissing(lngRemotePort) Then 'Added: 04-MAR-2002 If IsNumeric(lngRemotePort) Then 'Added: 04-MAR-2002 m_lngRemotePort = CLng(lngRemotePort) End If 'Added: 04-MAR-2002 End If 'Added: 04-MAR-2002 ' '---------------------------------------------------------- 'Added: 31-JUL-2002 '---------------------------------------------------------- If Len(m_strRemoteHost) = 0 Then Exit Sub '---------------------------------------------------------- ' m_varInternalState = istConnecting ' '------------------------------------------------------------------ 'Modified: 08-JULY-2002 '------------------------------------------------------------------ 'Here is a major change. Since version 1.0.6 (08-JULY-2002) the 'SCocket class doesn't try to resolve the IP address into a 'domain name while connecting. '------------------------------------------------------------------ ' 'Try to get 32 bit host address from the RemoteHost property value lngHostAddress = inet_addr(m_strRemoteHost) ' If lngHostAddress = INADDR_NONE Then ' 'The RemoteHost property doesn't contain a valid IP address string, 'so that is perhaps a domain name string that we need to resolve 'into IP address ' 'The ResolveHost function, that can be found in the MSocketSupport 'module, will call the WSAAsyncGetHostByName Winsock API function. 'That function is an asynchronous one, so code in this class will be executing 'after the call to the PostGetHostEvent procedure from the WindowProc function 'in the MSupportSocket. ' 'Also, as you can see, the second argument is a pointer to the object, that is 'this instance of the CSocket class. We need this because the callback function 'has to know to which object send the received host infromation. See the code 'in the MSocketSupport module for more information. ' 'Change the State property value mvarState = sckResolvingHost 'Debug.Print "mvarState = sckResolvingHost" ' m_lngRequestID = 0 m_lngRequestID = MSocketSupport.ResolveHost(m_strRemoteHost, ObjPtr(Me)) ' '------------------------------------------------------- 'Added: 04-JUNE-2002 '------------------------------------------------------- If m_lngRequestID = 0 Then Call DestroySocket '------------------------------------------------------- ' Else ' 'The RemoteHost property contains a valid IP address string, 'so we can go on connecting to the remote host. ' 'Build the sockaddr_in structure to pass it to the connect 'Winsock API function as an address of the remote host. With udtAddress ' .sin_addr = lngHostAddress .sin_family = AF_INET .sin_port = htons(UnsignedToInteger(CLng(m_lngRemotePort))) ' End With ' 'Call the connect Winsock API function in order to establish connection. lngRetValue = api_connect(m_lngSocketHandle, udtAddress, Len(udtAddress)) ' 'Since the socket we use is a non-blocking one, the connect Winsock API 'function should return a value of SOCKET_ERROR anyway. ' If lngRetValue = SOCKET_ERROR Then ' 'The WSAEWOULDBLOCK error is OK for such a socket ' If Not Err.LastDllError = WSAEWOULDBLOCK Then ' Else 'Change the State property value mvarState = sckConnecting End If ' End If ' End If End Sub Public Sub CloseSocket() Attribute CloseSocket.VB_Description = "Close current connection" ' Dim lngRetValue As Long 'value returned by the shutdown Winsock API function ' On Error Resume Next ' 'Why do we need to run the code that should not be running? If m_lngSocketHandle = INVALID_SOCKET Then Exit Sub ' If Not mvarState = sckConnected Then ' 'If the socket is not connected we can just close it Call DestroySocket mvarState = sckClosed ' Else ' 'If the socket is connected, it's another story. 'In order to be sure that no data will be lost the 'graceful shutdown of the socket should be performed. ' mvarState = sckClosing ' 'Call the shutdown Winsock API function in order to 'close the connection. That doesn't mean that the 'connection will be closed after the call of the 'shutdown function. Connection will be closed from 'the PostSocketEvent subroutine when the FD_CLOSE 'message will be received. ' 'For people who know what the FIN segment in the 'TCP header is - this function sends an empty packet 'with the FIN bit turned on. ' lngRetValue = shutdown(m_lngSocketHandle, SD_SEND) ' End If End Sub Public Sub Bind(Optional lngLocalPort As Long, Optional strLocalIP As String) Attribute Bind.VB_Description = "Binds socket to specific port and adapter" ' Dim lngRetValue As Long 'value returned by the bind Winsock API function Dim udtLocalAddr As sockaddr_in 'local socket address to bind to - used by the ' bind Winsock API function Dim lngAddress As Long '32-bit host address - value returned by ' the inet_addr Winsock API function ' On Error Resume Next ' 'If no socket has been created before, try to create a new one If Not SocketExists Then Exit Sub ' 'If the arguments of this function are not missing, they 'overwrites values of the RemoteHost and RemotePort properties. ' If Len(strLocalIP) > 0 Then m_strLocalIP = strLocalIP End If ' If lngLocalPort > 0 Then m_lngLocalPort = lngLocalPort End If ' If Len(m_strLocalIP) > 0 Then ' 'If the local IP is known, get the address 'from it with the inet_addr Winsock API function. lngAddress = inet_addr(m_strLocalIP) ' Else ' 'If the IP is unknown, assign the default interface's IP. 'Actually, this line is useless in Visual Basic code, 'as INADDR_ANY = 0 (IP = 0.0.0.0). lngAddress = INADDR_ANY ' End If ' If lngAddress = SOCKET_ERROR Then ' 'Bad address - go away Exit Sub ' End If ' 'Prepare the udtLocalAddr UDT that is a socket address structure. With udtLocalAddr ' 'host address (32-bits value) .sin_addr = lngAddress 'address family .sin_family = AF_INET 'port number in the network byte order .sin_port = htons(UnsignedToInteger(m_lngLocalPort)) 'Modified: 04-JUNE-2002 ' End With ' 'Call the bind Winsock API function in order to assign local address for the socket lngRetValue = api_bind(m_lngSocketHandle, udtLocalAddr, Len(udtLocalAddr)) ' If lngRetValue <> SOCKET_ERROR Then ' m_blnSocketIsBound = True 'Added: 10-MAR-2002 ' End If End Sub Public Sub Accept(requestID As Long) Attribute Accept.VB_Description = "Accept an incoming connection request" ' 'The requestID argument is provided with the ConnectRequest 'event of another instance of the CSocket class. Actually, 'this argument is a handle of the socket already created 'calling the Accept Winsock API function by that (another) 'instance of the CSocket class. ' Dim lngRetValue As Long 'value returned by the getsockname, getpeername, and ' getsockopt Winsock API functions Dim lngBuffer As Long 'the buffer to pass with the getsockopt Winsock API function Dim udtSockAddr As sockaddr_in 'socket address - used by the getsockname and getpeername ' Winsock API functions Dim udtHostent As HOSTENT 'structure to hold the host info - returned by the ' getsockname and getpeername Winsock API functions ' On Error Resume Next ' 'What we need to do in the body of this subroutine is to 'initialize the properties of the class that we can find 'values for. Also we need to register the socket with 'the RegisterSocket function from MSocketSupport module. ' 'Assign the socket handle m_lngSocketHandle = requestID ' 'Retrieve the connection end-points to initialize 'the following properties of the CSocket class: 'LocalPort, LocalIP, LocalHostName 'RemotePort, RemoteHostIP, RemoteHost ' 'Local end point ' lngRetValue = getsockname(m_lngSocketHandle, udtSockAddr, Len(udtSockAddr)) ' If lngRetValue = 0 Then ' 'LocalPort property m_lngLocalPort = IntegerToUnsigned(ntohs(udtSockAddr.sin_port)) 'LocalIP property m_strLocalIP = StringFromPointer(inet_ntoa(udtSockAddr.sin_addr)) 'LocalHostName property '---------------------------------------------------------------- 'Modified: 31-JUL-2002 '---------------------------------------------------------------- 'lngRetValue = gethostbyaddr(udtSockAddr.sin_addr, 4&, AF_INET) 'CopyMemory udtHostent, ByVal lngRetValue, Len(udtHostent) 'm_strLocalHostName = StringFromPointer(udtHostent.hName) m_strLocalHostName = m_strLocalIP '---------------------------------------------------------------- ' End If ' 'Remote end point ' lngRetValue = getpeername(m_lngSocketHandle, udtSockAddr, Len(udtSockAddr)) ' If lngRetValue = 0 Then ' 'RemotePort property m_lngRemotePort = IntegerToUnsigned(ntohs(udtSockAddr.sin_port)) 'RemoteHostIP property m_strRemoteHostIP = StringFromPointer(inet_ntoa(udtSockAddr.sin_addr)) 'RemoteHost property '---------------------------------------------------------------- 'Modified: 31-JUL-2002 '---------------------------------------------------------------- 'lngRetValue = gethostbyaddr(udtSockAddr.sin_addr, 4&, AF_INET) 'CopyMemory udtHostent, ByVal lngRetValue, Len(udtHostent) 'm_strRemoteHost = StringFromPointer(udtHostent.hName) m_strRemoteHost = m_strRemoteHostIP '---------------------------------------------------------------- ' End If ' 'Retrieve the socket type to initialize the Protocol property lngRetValue = getsockopt(m_lngSocketHandle, SOL_SOCKET, SO_TYPE, lngBuffer, LenB(lngBuffer)) ' If lngRetValue <> SOCKET_ERROR Then ' If lngBuffer = SOCK_STREAM Then mvarProtocol = sckTCPProtocol Else mvarProtocol = sckUDPProtocol End If ' End If ' 'Get default size of the Winsock's buffers. Call GetWinsockBuffers 'Added: 10-MAR-2002 ' If MSocketSupport.RegisterSocket(m_lngSocketHandle, ObjPtr(Me)) Then ' 'Change the State property value mvarState = sckConnected ' End If ' End Sub Public Property Get State() As StateConstants State = mvarState End Property Public Property Get SocketHandle() As Long Attribute SocketHandle.VB_Description = " Returns the socket handle" SocketHandle = m_lngSocketHandle End Property Public Property Get RemotePort() As Long Attribute RemotePort.VB_Description = "Returns/Sets the port to be connected to on the remote computer" RemotePort = m_lngRemotePort End Property Public Property Let RemotePort(NewValue As Long) m_lngRemotePort = NewValue End Property Public Property Get RemoteHostIP() As String Attribute RemoteHostIP.VB_Description = "Returns the remote host IP address" RemoteHostIP = m_strRemoteHostIP End Property Public Property Get RemoteHost() As String Attribute RemoteHost.VB_Description = "Returns/Sets the name used to identify the remote computer" RemoteHost = m_strRemoteHost End Property Public Property Let RemoteHost(NewValue As String) ' Dim lngHostAddress As Long '32 bit host address Dim lngRetValue As Long 'value returned by the setsockopt function ' m_strRemoteHost = NewValue ' If Len(NewValue) > 0 Then ' 'Check for a valid IP address string ' lngHostAddress = inet_addr(NewValue) ' If Not lngHostAddress = INADDR_NONE Then ' m_strRemoteHostIP = NewValue ' If Not mvarProtocol = sckUDPProtocol Then Exit Property If Not SocketExists Then Exit Property ' 'If the IP address is a brodcasting one set the option ' If Right(NewValue, 4) = ".255" And m_blnBroadcast = False Then ' lngRetValue = setsockopt(m_lngSocketHandle, SOL_SOCKET, SO_BROADCAST, 1&, 4&) ' If lngRetValue <> SOCKET_ERROR Then ' m_blnBroadcast = True ' End If ' ElseIf (Not (Right(NewValue, 4) = ".255")) And (m_blnBroadcast = True) Then ' lngRetValue = setsockopt(m_lngSocketHandle, SOL_SOCKET, SO_BROADCAST, 0&, 4&) ' If lngRetValue <> SOCKET_ERROR Then ' m_blnBroadcast = False ' End If ' End If ' End If ' End If ' End Property Public Property Get Protocol() As ProtocolConstants Attribute Protocol.VB_Description = "Returns/Sets the socket protocol" Protocol = mvarProtocol End Property Public Property Let Protocol(NewValue As ProtocolConstants) ' If m_lngSocketHandle = INVALID_SOCKET Then 'Modified: 10-MAR-2002 mvarProtocol = NewValue End If ' End Property Public Property Get LocalPort() As Long Attribute LocalPort.VB_Description = "Returns/Sets the port used on the local computer" LocalPort = m_lngLocalPort End Property Public Property Let LocalPort(NewValue As Long) m_lngLocalPort = NewValue End Property Public Property Get LocalIP() As String Attribute LocalIP.VB_Description = "Returns the local machine IP address" LocalIP = m_strLocalIP End Property Public Property Get LocalHostName() As String Attribute LocalHostName.VB_Description = "Returns the local machine name" LocalHostName = m_strLocalHostName End Property Public Property Get BytesReceived() As Long Attribute BytesReceived.VB_Description = "Returns the number of bytes received on this connection" BytesReceived = m_lngBytesReceived End Property Private Sub Class_Initialize() ' 'Socket's handle default value m_lngSocketHandle = INVALID_SOCKET 'Initialize the Winsock service m_lngMaxMsgSize = MSocketSupport.InitWinsockService ' End Sub Public Function vbSocket() As Long '******************************************************************************** 'Author :Oleg Gdalevich 'Purpose :Creates a new socket 'Returns :The socket handle if successful, otherwise - INVALID_SOCKET 'Arguments : '******************************************************************************** ' On Error Resume Next ' Dim lngRetValue As Long 'value returned by the socket API function ' 'Call the socket Winsock API function in order to create a new socket If mvarProtocol = sckUDPProtocol Then lngRetValue = api_socket(AF_INET, SOCK_DGRAM, IPPROTO_UDP) Else lngRetValue = api_socket(AF_INET, SOCK_STREAM, IPPROTO_TCP) End If ' If lngRetValue = INVALID_SOCKET Then ' Else ' If Not MSocketSupport.RegisterSocket(lngRetValue, ObjPtr(Me)) Then 'Modified: 04-JUNE-2002 '-------------------------------------------------- 'Added: 04-JUNE-2002 '-------------------------------------------------- lngRetValue = INVALID_SOCKET Call api_closesocket(lngRetValue) '-------------------------------------------------- ' End If ' End If ' 'Assign returned value vbSocket = lngRetValue ' End Function Friend Sub PostSocketEvent(ByVal lngEventID As Long, Optional ByVal lngError As Long) ' 'This procedure is called by the WindowProc callback function 'from the MSocketSupport module. The lngEventID argument is an 'ID of the network event occurred for the socket. The lngError 'argument contains an error code only if an error was occurred 'during an asynchronous execution. ' Dim lngBytesReceived As Long 'value returned by the RecvDataToBuffer function Dim lngRetValue As Long 'value returned by the getsockname Winsock API function Dim lngNewSocket As Long 'value returned by the accept Winsock API function Dim udtSockAddr As sockaddr_in 'remote socket address for the accept Winscok API function Dim udtHostent As HOSTENT 'structure to hold the host info - returned ' by the gethostbyaddr Winsock API function ' On Error Resume Next ' If lngError > 0 Then ' 'An error was occurred. ' 'Change a value of the State property mvarState = sckError 'Debug.Print "mvarState = sckError" 'Close the socket Call DestroySocket 'The OnError event is just for this case RaiseEvent OnError(CInt(lngError), GetErrorDescription(lngError), 0, "", "", 0, False) 'We have nothing to do here anymore Exit Sub ' End If ' Select Case lngEventID ' Case FD_READ ' 'Some data has arrived for this socket. 'Call the RecvDataToBuffer function that move arrived data 'from the Winsock buffer to the local one and returns number 'of bytes received. lngBytesReceived = RecvDataToBuffer ' 'The BytesReceived property contains number of bytes in 'the local buffer of the class. m_lngBytesReceived = m_lngBytesReceived + lngBytesReceived ' 'The OnDataArrival event is just for the case when some data 'was retieved from the Winsock buffer. If lngBytesReceived > 0 Then RaiseEvent OnDataArrival(Len(m_strRecvBuffer)) End If ' Case FD_WRITE ' 'This message means that the socket in a write-able 'state, that is, buffer for outgoing data of the transport 'service is empty and ready to receive data to send through 'the network. ' 'If the local buffer for outgoing data (m_strSendBuffer) is 'not empty, the previous call of the send/sendto Winsock API 'function was failed. Call the SendBufferedData procedure in 'oreder to try to send that data again. If Len(m_strSendBuffer) > 0 Then ' Call SendBufferedData Else ' If m_blnSendFlag Then 'Added: 12-SEP-2002 m_blnSendFlag = False 'Added: 12-SEP-2002 RaiseEvent OnSendComplete 'Added: 23-AUG-2002 End If ' End If ' Case FD_OOB ' 'Ignored. ' Case FD_ACCEPT ' 'When the socket is in a listening state, arrival of this message 'means that a connection request was received. Call the accept 'Winsock API function in oreder to create a new socket for the 'requested connection. lngNewSocket = api_accept(m_lngSocketHandle, udtSockAddr, Len(udtSockAddr)) ' 'Let the client application know that the request was received 'and pass with the event argument a handle of the recently created 'socket. The client application should create a new instance of 'the CSocket class, and then use the socket handle (lngNewSocket) 'to initialize its properties. Another way is to do not create 'one more instance of this class. We may close existing socket, 'and then accept the new handle: ' ' Private Sub objSocket_OnConnectionRequest(ByVal requestID As Long) ' If objSocket.State <> sckClosed Then objSocket.CloseSocket ' objSocket.Accept (requestID) ' End Sub ' RaiseEvent OnConnectionRequest(lngNewSocket) ' Case FD_CONNECT ' 'Arrival of this message means that the connection initiated by the call 'of the connect Winsock API function was successfully established. ' 'Get the connection local end-point parameters ' lngRetValue = getsockname(m_lngSocketHandle, udtSockAddr, LenB(udtSockAddr)) ' If lngRetValue = 0 Then ' 'LocalPort property m_lngLocalPort = IntegerToUnsigned(ntohs(udtSockAddr.sin_port)) 'LocalIP property m_strLocalIP = StringFromPointer(inet_ntoa(udtSockAddr.sin_addr)) 'LocalHostName property lngRetValue = gethostbyaddr(udtSockAddr.sin_addr, 4&, AF_INET) '--------------------------------------------------------------- 'Modified: 31-JUL-2002 '--------------------------------------------------------------- If lngRetValue <> 0 Then CopyMemory udtHostent, ByVal lngRetValue, Len(udtHostent) m_strLocalHostName = StringFromPointer(udtHostent.hName) Else m_strLocalHostName = m_strLocalIP End If '--------------------------------------------------------------- ' End If ' ' -- Modified: 04-MAR-2002 -- ' 'Change a value of the State property mvarState = sckConnected ' 'Let the client app know that the connection was established. RaiseEvent OnConnect ' ' -- --------------------- -- ' Case FD_CLOSE ' 'This message means that the remote host is closing the conection ' '------------------------------------------------------------------- 'Modified: 20-AUG-2002 'Thanks to mreggio and other vbip.com Forum members. '------------------------------------------------------------------- Do ' lngBytesReceived = RecvDataToBuffer ' If lngBytesReceived > 0 Then RaiseEvent OnDataArrival(Len(m_strRecvBuffer)) End If ' Loop Until lngBytesReceived = 0 Or lngBytesReceived = SOCKET_ERROR ' If mvarState = sckClosing Then ' '--------------- 'Don't even read this as it doesn't work on a very-very 'fast connection, for example: localhost<->localhost :). 'The Do..Loop was moved up, now you can see it above the '"If mvarState = sckClosing Then" statement '----------------- ' 'If a value of the State property already is sckClosing, 'the closing of the connection was initiated by the local 'end-point (this socket) of the connection. In other words, 'the shutdown Winsock API function has been called before '(the FIN segment is already sent by the local end-point). ' 'In this case we need wait until all the data sent by the 'remote end-point of the connection will be received. ' 'Do ' ' ' lngBytesReceived = RecvDataToBuffer ' ' ' If lngBytesReceived > 0 Then ' RaiseEvent OnDataArrival(Len(m_strRecvBuffer)) ' End If ' ' 'Loop Until lngBytesReceived = 0 Or lngBytesReceived = SOCKET_ERROR ' '------------------------------------------------------------------- Else ' mvarState = sckClosing 'Debug.Print "mvarState = sckClosing" ' 'If a value of the State property is not sckClosing, the 'connectoin is closing by the remote end-point of the 'connection (the FIN segment is sent by the remote host). 'In this case we need send all the remained data from the 'local buffer before to close the socket. If Len(m_strSendBuffer) > 0 Then ' Call SendBufferedData ' End If ' End If ' 'Close the socket Call DestroySocket ' 'Change a value of the State property mvarState = sckClosed 'Debug.Print "mvarState = sckClosed" ' 'Let the client app know that the connection is closed RaiseEvent OnClose ' End Select ' End Sub Friend Sub PostGetHostEvent(ByVal lngRequestID As Long, ByVal lngHostAddress As Long, strHostName As String, Optional lngError As Long) ' 'This procedure is called by the WindowProc callback function 'from the MSocketSupport module. Think about it as about result 'returned by the ResolveHost function called from this class. ' Dim udtAddress As sockaddr_in 'socket address - used by the connect Winsock API function Dim lngRetValue As Long 'value returned by the connect Winsock API function Dim lngPtrToAddress As Long 'pointer to the string that contains IP address - value 'returned by the inet_ntoa Winsock API function ' On Error Resume Next ' If lngError > 0 Then ' 'An error was occerred during resolving the host hame. 'For example: "Host not found" ' '---------------------------------------------------------------- 'Added: 28-APR-2002 'There is the case when a computer has a valid IP address 'but its name cannot be resolved. In this case the code should 'countinue the execution - we just don't need to change the 'RemoteHost property value. '---------------------------------------------------------------- ' 'Does the strHostName argument contain a valid IP address? lngHostAddress = inet_addr(strHostName) ' If lngHostAddress = INADDR_NONE Then 'Added: 28-APR-2002 ' 'Change a value of the State property mvarState = sckError ' 'Let the client app know that an error was occurred. RaiseEvent OnError(CInt(lngError), GetErrorDescription(lngError), 0, "", "", 0, False) ' Exit Sub ' Else 'Added: 28-APR-2002 ' 'Nothing to do here 'Both properties the RemoteHost and RemoteHostIP 'have the same value of the IP address string. ' End If 'Added: 28-APR-2002 ' End If ' 'Check the id value - Do we really need this? If lngRequestID = 0 Then Exit Sub ' If lngRequestID = m_lngRequestID Then ' 'Change a value of the State property mvarState = sckHostResolved 'Debug.Print "mvarState = sckHostResolved" ' 'Initialize the RemoteHost property m_strRemoteHost = strHostName ' 'Get pointer to the string that contains the IP address lngPtrToAddress = inet_ntoa(lngHostAddress) ' 'Retrieve that string by the pointer and init the 'RemoteHostIP property. m_strRemoteHostIP = StringFromPointer(lngPtrToAddress) ' 'The ResolveHost function may be called from two methods 'of the class: Connect and SendData. The m_varInternalState 'variable tells us where the ResolveHost function called 'from, and thus what to do here. ' If m_varInternalState = istConnecting Then ' 'The ResolveHost was called from the Connect method, so 'we need to continue the process of the connection establishing. ' 'Build the sockaddr_in structure to pass it to the connect 'Winsock API function as an address of the remote host. With udtAddress ' .sin_addr = lngHostAddress .sin_family = AF_INET .sin_port = htons(UnsignedToInteger(CLng(m_lngRemotePort))) ' End With ' 'Call the connect Winsock API function in order to establish connection. lngRetValue = api_connect(m_lngSocketHandle, udtAddress, Len(udtAddress)) ' 'Since the socket we use is a non-blocking one, the connect Winsock API 'function should return a value of SOCKET_ERROR anyway. ' If lngRetValue = SOCKET_ERROR Then ' 'The WSAEWOULDBLOCK error is OK for such a socket ' If Not Err.LastDllError = WSAEWOULDBLOCK Then 'Modified: 31-JUL-2002 RaiseEvent OnError(Err.LastDllError, GetErrorDescription(Err.LastDllError), 0&, "CSocket.PostGetHostEvent", "", 0&, False) Else 'Change the State property value mvarState = sckConnecting 'Debug.Print "mvarState = sckConnecting" End If ' End If ' ElseIf m_varInternalState = istSendingDatagram Then ' 'The ResolveHost was called from the SendData method in 'the case when a message-oriented (UDP) socket is used. ' Call SendBufferedData ' End If ' End If ' End Sub Private Function SocketExists() As Boolean ' If m_lngSocketHandle = INVALID_SOCKET Then ' 'If the m_lngSocketHandle is not a valid value, call 'the vbSocket function in order to create a new socket m_lngSocketHandle = vbSocket ' If m_lngSocketHandle = SOCKET_ERROR Then ' 'A value of SOCKET_ERROR means that the socket was not created. 'In this case the SocketExists function must return False Exit Function ' Else ' 'Get default size of the Winsock's buffers. Call GetWinsockBuffers 'Modified: 10-MAR-2002 ' End If ' End If ' 'The m_lngSocketHandle variable contains a valid socket 'handle value. In this case the function returns True. SocketExists = True ' End Function Private Sub GetWinsockBuffers() ' 'This subroutine is to retrieve default size of the Winsock buffers. 'These values will be stored in the module level variables: 'm_lngSendBufferLen and m_lngRecvBufferLen. 'It can be called from the SocketExists and Accept functions. ' 'Added: 10-MAR-2002 ' Dim lngRetValue As Long 'value returned by the getsockopt Winsock API function Dim lngBuffer As Long 'buffer to pass with the getsockopt call ' If mvarProtocol = sckTCPProtocol Then 'Buffer for incoming data lngRetValue = getsockopt(m_lngSocketHandle, SOL_SOCKET, SO_RCVBUF, lngBuffer, 4&) m_lngRecvBufferLen = lngBuffer 'Buffer for outgoing data lngRetValue = getsockopt(m_lngSocketHandle, SOL_SOCKET, SO_SNDBUF, lngBuffer, 4&) m_lngSendBufferLen = lngBuffer Else 'the m_lngMaxMsgSize value is returned by InitWinsockService 'function from the MSocketSupport module m_lngSendBufferLen = m_lngMaxMsgSize m_lngRecvBufferLen = m_lngMaxMsgSize End If ' End Sub Private Function RecvDataToBuffer() As Long ' 'This function is to retrieve data from the Winsock buffer 'into the class local buffer. The function returns number 'of bytes retrieved (received). ' Dim lngBytesReceived As Long 'value returned by recv/recvfrom Winsock API function Dim lngRetValue As Long 'value returned by gethostbyaddr Winsock API function Dim strTempBuffer As String 'just a temporary buffer Dim arrBuffer() As Byte 'buffer to pass to the recv/recvfrom Winsock API function Dim udtSockAddr As sockaddr_in 'socket address of the remote peer Dim lngSockAddrLen As Long 'size of the sockaddr_in structure Dim udtHostent As HOSTENT 'used to get host name with gethostbyaddr function ' 'Prepare the buffer to pass it to the recv/recvfrom Winsock API function. 'The m_lngRecvBufferLen variable was initialized during creating 'of the socket, see the vbSocket function to find out how. ReDim arrBuffer(m_lngRecvBufferLen - 1) ' If mvarProtocol = sckTCPProtocol Then ' 'If the socket is a connection-oriented one, just call the recv function 'to retrieve all the arrived data from the Winsock buffer. lngBytesReceived = recv(m_lngSocketHandle, arrBuffer(0), m_lngRecvBufferLen, 0&) ' Else ' 'If the socket uses UDP, it's another story. As stated in the MS Winsock Control 'documentation after receiving data the RemoteHost, RemoteHostIP, and RemotePort 'properties contains parameters of the machine sending the UDP data. To achive 'such a behavior we must use the recvfrom Winsock API function. ' lngSockAddrLen = Len(udtSockAddr) ' lngBytesReceived = recvfrom(m_lngSocketHandle, arrBuffer(0), m_lngRecvBufferLen, _ 0&, udtSockAddr, lngSockAddrLen) ' If Not lngBytesReceived = SOCKET_ERROR Then ' 'Now the udtSockAddr contains a socket address of the remote host. 'Initialize the RemoteHost, RemoteHostIP, and RemotePort properties. ' With udtSockAddr ' 'RemotePort property m_lngRemotePort = IntegerToUnsigned(ntohs(.sin_port)) 'RemoteHostIP property m_strRemoteHostIP = StringFromPointer(inet_ntoa(.sin_addr)) 'RemoteHost property lngRetValue = gethostbyaddr(.sin_addr, 4&, AF_INET) CopyMemory udtHostent, ByVal lngRetValue, Len(udtHostent) m_strRemoteHost = StringFromPointer(udtHostent.hName) ' End With ' End If ' End If ' If lngBytesReceived > 0 Then ' 'Convert a byte array into the VB string strTempBuffer = StrConv(arrBuffer(), vbUnicode) 'Store received data in the local buffer for incoming data - m_strRecvBuffer m_strRecvBuffer = m_strRecvBuffer & Left$(strTempBuffer, lngBytesReceived) 'Return number of received bytes. RecvDataToBuffer = lngBytesReceived ' End If ' End Function Private Function RecvData(varData As Variant, blnPeek As Boolean, Optional varType As Variant, Optional maxLen As Variant) As Long ' 'This function is to retrieve data from the local buffer (m_strRecvBuffer). 'It can be called by two public methods of the class - GetData and PeekData. 'Behavior of the function is defined by the blnPeek argument. If a value of 'that argument is True, the function returns number of bytes in the 'local buffer, and copy data from that buffer into the varData argument. 'If a value of the blnPeek is False, then this function returns number of 'bytes received, and move data from the local buffer into the varData 'argument. MOVE means that data will be removed from the local buffer. ' Dim strRecvData As String 'temporary string buffer Dim arrBuffer() As Byte 'temporary byte array buffer ' 'If the local buffer is empty, go away - we have nothing to do here. If Len(m_strRecvBuffer) = 0 Then Exit Function ' If IsEmpty(maxLen) Then maxLen = 0 End If ' If (Not maxLen > Len(m_strRecvBuffer)) And (maxLen > 0) Then ' strRecvData = Left$(m_strRecvBuffer, CLng(maxLen)) ' If Not blnPeek Then m_strRecvBuffer = Mid$(m_strRecvBuffer, CLng(maxLen + 1)) End If ' arrBuffer() = StrConv(strRecvData, vbFromUnicode) ' Else ' arrBuffer() = StrConv(m_strRecvBuffer, vbFromUnicode) ' If Not blnPeek Then m_strRecvBuffer = "" End If ' End If ' If IsEmpty(varType) Then varData = CStr(StrConv(arrBuffer(), vbUnicode)) Else ' Select Case varType Case vbArray + vbByte 'Modified 28-MAY-2002. Thanks to Michael Freidgeim '-------------------------------- 'Dim strArray As String 'strArray = StrConv(arrBuffer(), vbUnicode) 'varData = StrConv(strArray, vbFromUnicode) varData = arrBuffer() '-------------------------------- Case vbBoolean Dim blnData As Boolean CopyMemory blnData, arrBuffer(0), LenB(blnData) varData = blnData Case vbByte Dim bytData As Byte CopyMemory bytData, arrBuffer(0), LenB(bytData) varData = bytData Case vbCurrency Dim curData As Currency CopyMemory curData, arrBuffer(0), LenB(curData) varData = curData Case vbDate Dim datData As Date CopyMemory datData, arrBuffer(0), LenB(datData) varData = datData Case vbDouble Dim dblData As Double CopyMemory dblData, arrBuffer(0), LenB(dblData) varData = dblData Case vbInteger Dim intData As Integer CopyMemory intData, arrBuffer(0), LenB(intData) varData = intData Case vbLong Dim lngData As Long CopyMemory lngData, arrBuffer(0), LenB(lngData) varData = lngData Case vbSingle Dim sngData As Single CopyMemory sngData, arrBuffer(0), LenB(sngData) varData = sngData Case vbString Dim strData As String strData = StrConv(arrBuffer(), vbUnicode) varData = strData ' End Select ' End If ' 'Added 28-MAY-2002. Thanks to Michael Freidgeim m_lngBytesReceived = Len(m_strRecvBuffer) 'reset BytesReceived after Getdata ' End Function Private Sub DestroySocket() ' 'The purpose of this subroutine is to unregister the socket with 'UnregisterSocket that can be found in the MSocketSupport module 'and close the socket with the closesocket Winsock API function. ' Dim lngRetValue As Long 'value returned by the closesocket 'Winsock AP function ' m_strRecvBuffer = "" 'Added: 17-OCT-2002 ' If Not m_lngSocketHandle = INVALID_SOCKET Then ' 'Unregister the socket. For more info on how it works 'see the code of the function in the MSocketSupport module Call MSocketSupport.UnregisterSocket(m_lngSocketHandle) ' 'Close the socket with the closesocket Winsock API function. lngRetValue = api_closesocket(m_lngSocketHandle) ' 'Change the SocketHandle property value m_lngSocketHandle = INVALID_SOCKET ' 'If the bind Winsock API function has been called on 'this socket, m_blnSocketIsBound = True. We need to 'change this value. m_blnSocketIsBound = False 'Added: 10-MAR-2002 ' m_blnBroadcast = False 'Added: 09-JULY-2002 ' End If ' End Sub Private Sub Class_Terminate() ' If Not m_lngSocketHandle = INVALID_SOCKET Then Call DestroySocket End If ' Call CleanupWinsock ' End Sub Private Sub SendBufferedData() ' 'This procedure sends data from the local buffer (m_strSendBuffer). 'The data from the client application is passed with the SendData 'method of the class as an argument and is stored in the local 'buffer until all the data from that buffer will be sent using this 'subroutine. ' 'Why do we need to store data in the local buffer? There are some 'things happenning in the Winsock's buffer for outgoing data since 'we're using non-blocking sockets' calls. If that buffer is full, 'the transport subsystem doesn't take the data and the send/sendto 'functions return a value of SOCKET_ERROR, Err.LastDllError give 'us a value of WSAEWOULDBLOCK. This means that if the socket would 'be a blocking one, such a call would block socket until the buffer 'will be freed and ready to accept some data to send. ' 'So this procedure can be called several (mostly not more than two) 'times for the same chunk of data. First call is in the body of the 'SendData method, and other calls (if necessary) will be performed 'from the PostSocketEvent subroutine, as soon as the FD_WRITE message 'will be received. The arrival of the FD_WRITE message means that a 'socket is in a write-able state - its buffer is ready to get data. ' Dim lngRetValue As Long 'value returned by send/sendto Winsock API function Dim arrData() As Byte 'data to send with the send/sendto function Dim lngBufferLength As Long 'size of the data buffer to send Dim udtSockAddr As sockaddr_in 'address of the remote socket - for the sendto function ' 'The send/sendto function needs this value for one of its arguments lngBufferLength = Len(m_strSendBuffer) m_blnSendFlag = True ' 'Convert data from a VB string to a byte array arrData() = StrConv(m_strSendBuffer, vbFromUnicode) ' If mvarProtocol = sckTCPProtocol Then ' 'just call the send function in order to send data via connection lngRetValue = send(m_lngSocketHandle, arrData(0), lngBufferLength, 0&) ' Else ' 'With UDP socket we are going to use the sendto Winsock API function. 'This function needs the socket address of the remote host to send 'message to. ' If Len(m_strRemoteHostIP) = 0 Then ' 'If the RemoteHostIP property is empty, we don't know 'the remote IP so we need to resolve that address. ' m_varInternalState = istSendingDatagram m_lngRequestID = MSocketSupport.ResolveHost(m_strRemoteHost, ObjPtr(Me)) ' 'The ResolveHost is an asynchronous call. This subroutine wiil be called 'one more time from the PostGetHostEvent procedure when the host will be 'resolved. ' Else ' 'If we are here the host was resolved successfully and the RemoteHostIP 'property provides us with IP to send a UDP message to. ' 'Build the sockaddr_in structure to pass the remote socket address 'to the sendto function. With udtSockAddr .sin_addr = inet_addr(m_strRemoteHostIP) .sin_port = htons(UnsignedToInteger(m_lngRemotePort)) .sin_family = AF_INET End With ' 'Call the sendto function in order to send a UDP message lngRetValue = sendto(m_lngSocketHandle, arrData(0), lngBufferLength, 0&, udtSockAddr, Len(udtSockAddr)) ' End If ' End If ' If lngRetValue <> SOCKET_ERROR Then ' 'The data were sent successfully. Raise the OnSendProgress or 'OnSendComplete event to let the client app know. ' If Len(m_strSendBuffer) > lngRetValue Then ' m_strSendBuffer = Mid$(m_strSendBuffer, lngRetValue + 1) ' Else ' m_strSendBuffer = "" ' '--------------------------------------------- 'Modified: 23-AUG-2002 '--------------------------------------------- 'RaiseEvent OnSendComplete Call PostMessage(p_lngWindowHandle, p_lngWinsockMessage, m_lngSocketHandle, FD_WRITE) '--------------------------------------------- End If ' RaiseEvent OnSendProgress(lngRetValue, Len(m_strSendBuffer)) ' End If ' End Sub